perm filename SPINE.SAI[GEM,BGB] blob
sn#030943 filedate 1973-03-27 generic text, type T, neo UTF8
00100 COMMENT ⊗ VALID 00016 PAGES
00200 C REC PAGE DESCRIPTION
00300 C00001 00001
00400 C00003 00002 BEGIN "SPINE"
00500 C00008 00003 INITIAL ITEMS
00600 C00009 00004 MACROS TO DEFINE RECORDS
00700 C00011 00005 VARIOUS TYPE CODES
00800 C00012 00006 VARIOUS VARIABLES & DEFS
00900 C00013 00007 USEFUL IO ROUTINES
01000 C00015 00008 RECORD GENERATION
01100 C00016 00009 SIMPLE PROCEDURE TRANSFORM(INTEGER GSREAL ARRAY XF)
01200 C00018 00010 SIMPLE INTEGER PROCEDURE NGON(INTEGER SIDES)
01300 C00019 00011 INTEGER PROCEDURE C_CYL(ITEMVAR CYL,PNAM)
01400 C00022 00012 INTEGER PROCEDURE C_SPHERE(ITEMVAR SPH,PNAM)
01500 C00025 00013 RECURSIVE INTEGER PROCEDURE C_BODY(ITEMVAR BODYI,PNAM)
01600 C00028 00014 INTEGER PROCEDURE SHOW_BODY(ITEMVAR BODYI,PNAM)
01700 C00029 00015 BODY DECLARATION PROCEDURES
01800 C00032 00016
01900 C00034 ENDMK
02000 C⊗;
00100 BEGIN "SPINE"
00200
00300 REQUIRE "ABBREV.SAI[S,RHT]" SOURCE_FILE;
00400 REQUIRE "MACROS.SAI[S,RHT]" SOURCE_FILE;
00500 REQUIRE "LEPAUX.SAI[S,RHT]" SOURCE_FILE;
00600 REQUIRE "IOMOD.HDR[S,RHT]" SOURCE_FILE;
00700 REQUIRE "GEOMES.HDR[GEM,BGB]" SOURCE_FILE;
00800
00900 DEFINE DEBUGGING=1;
01000
01100 EXTERNAL REAL PROCEDURE SIN(REAL X);
01200 EXTERNAL REAL PROCEDURE COS(REAL X);
01300
01400 REQUIRE 1000 NEW_ITEMS;
01500 REQUIRE 400 PNAMES;
01600
01700 IFC DEBUGGING THENC
01800 PRELOAD_WITH 0;OWN INTEGER ARRAY PATCH[0:127];
01900 ENDC
02000
02100 COMMENT
02200
02300 Object representation is as follows:
02400
02500 Body prototype:
02600
02700 A body is an item. The props field gives the basic type, which
02800 may be (1) a cylinder -- (see below), or (2) a "sphere" --
02900 i.e. a body created by rotation, or (3) a list of
03000 parts -- the list being the datum of the item.
03100
03200 Part:
03300
03400 A part is a record whose fields are
03500
03600 XFORM(part) -- item whose datum is a transformation
03700 matrix wrt the parent body coords
03800 BPROT(part) -- a body prototype
03900 ROLE(part) -- 0→union, 1→subtraction 2→intersection
04000 PARTID(part) -- name of this part within this body
04100 GENID(part) -- name to be given to any edges generated
04200 in fusing the part with the body. If either id
04300 is not given (i.e. cvi(0)) then the name of the
04400 parent part is to be used.
04500
04600 Cylinders:
04700
04800 A cylinder is a record whose fields are
04900
05000 AXISL(cyl) -- real number giving the length of the spine
05100 The ends of the axis are at (0,0,0) & (0,0,L)
05200 in the cylinders own coord system.
05300 SIZE0(cyl) -- scale factor for face at the point (0,0,0)
05400 SIZEL(cyl) -- scale factor for face at the point (0,0,L)
05500 CHMETH(cyl) -- e.g. linear, circular.
05600 FPROT(cyl) -- face prototype of cylinder
05700 ZFEID(cyl) -- item to be used as "name" for z=0 edges
05800 LFEID(cyl) -- item to be used as "name" for z=AXISL edges
05900 SFEID(cyl) -- item to be used as "name" for side edges
06000 (if any of the edgeids is cvi(0), the assigned
06100 part name will be used
06200
06300 Spheres
06400
06500 Spheres are formed by rotating a wire "cross-section" thru
06600 2π about the x axis.
06700
06800 A sphere is a record whose fields are
06900 SSIZE(sph) -- dilation factor
07000 XSPROT(sph) -- cross section prototype
07100 (actually half a cross section)
07200
07300 Face:
07400
07500 A face is an item whoses props says it is either (1) a circle (code=2)
07600 whose datum is the radius, or (2) a polygon (code=1), or (3) a perimeter
07700 (code=0). Cases 2 and 3 are distinguished to give some guide as to when
07800 sampling is legal. For these two cases, the datum is a real
07900 array P[0:N,0:1] for which MEMLOC(P[0,0],INTEGER) is N (the
08000 number of points, & [P[I,0],P[I,1]) = (Xi,Yi). The points are
08100 assumed to lie in clockwise order about the face.
08200
08300 Cross sections:
08400
08500 a cross section is an item whose props say that it is (1) (code=0) a perimeter.
08600 (2) (code=1) a set of line segments, or (3) a half circle (code=2).
08700
08800 In the first two cases, the representation is like that for a Face. For
08900 case 3, the datum is the radius.
09000
09100 ;
09200
00100 COMMENT INITIAL ITEMS;
00200
00300 DXITEM (SUBPART); ! SUBPART⊗prt1≡prt2;
00400 DXITEM (LINEAR); ! CHANGE METHOD IS LINEAR;
00100 COMMENT MACROS TO DEFINE RECORDS;
00200
00300 DEFINE RECFLD(NAME,II,TYP)=
00400 ⊂
00500 DEFINE NAME(XXX)"{}"=
00600 {MEMORY[LOCATION(∂(XXX,INTEGER ARRAY)[II]),TYP]};
00700 ⊃;
00800
00900 ! DEFINITIONS FOR PART RECORD;
01000
01100 RECFLD(XFORM,0,ITEMVAR);
01200 RECFLD(BPROT,1,ITEMVAR);
01300 RECFLD(ROLE,2,INTEGER);
01400 RECFLD(PARTID,3,ITEMVAR);
01500 RECFLD(GENID,4,ITEMVAR);
01600 DEFINE PRECIX=4; ! MAX REC SIZE;
01700
01800 ! DEFINITIONS FOR CYLINDER RECORD;
01900
02000 RECFLD(AXISL,0,REAL);
02100 RECFLD(SIZE0,1,REAL);
02200 RECFLD(SIZEL,2,REAL);
02300 RECFLD(CHMETH,3,ITEMVAR);
02400 RECFLD(FPROT,4,ITEMVAR);
02500 RECFLD(ZFEID,5,ITEMVAR);
02600 RECFLD(LFEID,6,ITEMVAR);
02700 RECFLD(SFEID,7,ITEMVAR);
02800 DEFINE CYLRECIX=7; ! MAX REC INX;
02900
03000 ! DEFINITIONS FOR A SPHERE RECORD;
03100
03200 RECFLD(SSIZE,0,REAL);
03300 RECFLD(XSPROT,1,ITEMVAR);
03400 DEFINE SPHRECIX=1; ! MAX INX
03500
03600 ! DEFINITIONS FOR FACE PROTOTYPE (AND FOR CROSS SECTION);
03700 DEFINE NPOINTS(F)=⊂∂(F,INTEGER ARRAY)[0,0]⊃;
03800 DEFINE FACEXC(F,I)=⊂∂(F,REAL ARRAY)[I,0]⊃;
03900 DEFINE FACEYC(F,I)=⊂∂(F,REAL ARRAY)[I,1]⊃;
04000
00100 COMMENT VARIOUS TYPE CODES;
00200
00300 ! TYPES OF BODIES;
00400
00500 DEFINE CYLCOD=1; ! A CYLINDER;
00600 DEFINE SPHCOD=2; ! A SPHERE;
00700 DEFINE PLBCOD=3; ! A PARTS LIST;
00800
00900 ! ROLES FOR A PART;
01000
01100 DEFINE UCOD=0; ! UNION;
01200 DEFINE SCOD=1; ! SUBTRACTION;
01300 DEFINE ICOD=2; ! INTERSECTION;
01400 DEFINE RUB=3; ! UPPER BOUND ON CASES;
01500
01600 ! KINDS OF CROSS SECTIONS AND FACES;
01700 DEFINE PERCOD=0; ! PERIMETER;
01800 DEFINE POLCOD=1; ! POLYGON;
01900 DEFINE HCCOD=2; ! HALF CIRCLE (USED FOR XS);
02000 DEFINE CIRCOD=2; ! CIRCLE (FOR FACES);
02100 DEFINE XSUB=3; ! UPPER BOUND FOR XS;
02200 DEFINE FUB=3; ! UPPER BOUND FOR FACES
00100 COMMENT VARIOUS VARIABLES & DEFS;
00200
00300 DEFINE CIRCLESIDES=16; ! THE NUMBER OF SIDES IN A CIRCLE;
00400
00500 DEFINE PTNODE(E)=⊂MEMORY[E+8,ITEMVAR]⊃; ! CONTAINS THE
00600 POINTER AT THE PARTID FOR A GEOMED EDGE;
00700
00800 DEFINE NAMELESS=⊂CVI(0)⊃;
00900
01000 DEFINE ALT(X)=⊂(MEMORY[X+6] LSH -18)⊃;
01100
01200 INTEGER SHOP, ! THE WORLD IN WHICH EVERYTHING IS BUILT;
01300 WINDOW, ! THE WINDOW;
01400 CAMERA; ! THE CAMERA;
00100 COMMENT USEFUL IO ROUTINES;
00200
00300 PROCEDURE PRINT_REC(ITEMVAR REC);
00400 BEGIN
00500 CASE PROPS(REC) OF
00600 BEGIN
00700
00800 [CYLCOD] BEGIN
00900 WRITEON("CYLINDER ");WRITEON(ITMNAM(REC));
01000 WRITEON("BASE = ");WRITE(CVOS(∂(REC,INTEGER)));
01100 WRITEON(" ");WRITEON(CVF(AXISL(REC)));
01200 WRITEON(" ");WRITEON(CVF(SIZE0(REC)));
01300 WRITEON(" ");WRITEON(CVF(SIZEL(REC)));
01400 WRITEON(" ");WRITEON(ITMNAM(CHMETH(REC)));
01500 WRITEON(" ");WRITEON(ITMNAM(ZFEID(REC)));
01600 WRITEON(" ");WRITEON(ITMNAM(LFEID(REC)));
01700 WRITEON(" ");WRITEON(ITMNAM(SFEID(REC)));
01800 WRITE(CRLF);
01900 END;
02000
02100 [SPHCOD] BEGIN
02200 WRITEON("SPHERE ");WRITEON(ITMNAM(REC));
02300 WRITEON("BASE = ");WRITE(CVOS(∂(REC,INTEGER)));
02400 WRITEON(" ");WRITEON(CVF(SSIZE(REC)));
02500 WRITEON(" ");WRITEON(ITMNAM(XSPROT(REC)));
02600 WRITE(CRLF);
02700 END;
02800
02900 [PLBCOD] BEGIN
03000 ITEMVAR PTI;
03100 WRITEON("PARTS LIST BODY ");WRITEON(ITMNAM(REC));
03200 WRITEON("BASE = ");WRITE(CVOS(∂(REC,INTEGER)));
03300 ∀ PTI | PTI ε ∂(REC,LIST) DO
03400 BEGIN
03500 WRITEON("PART: ");WRITEON(ITMNAM(PTI));
03600 WRITEON(" PROT: ");WRITEON(ITMNAM(BPROT(PTI)));
03700 WRITEON(" ROLE: ");WRITEON(CVS(ROLE(PTI)));
03800 WRITEON(" ");WRITEON(ITMNAM(PARTID(PTI)));
03900 WRITEON(" ");WRITE(ITMNAM(GENID(PTI)));
04000 END;
04100 WRITE(CRLF);
04200 END
04300
04400 END;
04500 END;
00100 COMMENT RECORD GENERATION;
00200
00300 INTEGER ARRAY ITEMVAR PROCEDURE RECORD(INTEGER MAXIX);
00400 BEGIN
00500 INTEGER ARRAY BAZ[0:MAXIX];
00600 RETURN(NEW(BAZ));
00700 END;
00800
00900 LIST PARTNAMES; INITIALIZE(PARTNAMES←NIL);
01000
01100 INTEGER ITEMVAR PROCEDURE PIDREC(ITEMVAR PN0,PN1);
01200 BEGIN
01300 ITEMVAR PN;
01400 IF #(PN1) THEN
01500 BEGIN
01600 PN←NEW( #(PN1));
01700 IF #(PN0) THEN MAKE SUBPART⊗PN0≡PN;
01800 PARTNAMES[∞+1]←PN;
01900 RETURN(PN);
02000 END;
02100 RETURN(PN0);
02200 END;
00100 SIMPLE PROCEDURE TRANSFORM(INTEGER GS;REAL ARRAY XF);
00200 BEGIN
00300 IFC DEBUGGING THENC
00400 WRITE("TRANSFORM GEOMED STRUCTURE :"&CVOS(GS));
00500 WRITEON(" "&CVF(XF[1]));
00600 WRITEON(" "&CVF(XF[2]));
00700 WRITEON(" "&CVF(XF[3]));
00800 WRITEON(" "&CVF(XF[4]));
00900 WRITEON(" "&CVF(XF[5]));
01000 WRITEON(" "&CVF(XF[6]));
01100 WRITE(" "&CVF(XF[7]));
01200 ENDC
01300 ROTATE(-GS,XF[4],XF[5],XF[6]);
01400 SHRINK(-GS,XF[7],XF[7],XF[7]);
01500 TRANSLATE(GS,XF[1],XF[2],XF[3]);
01600 END;
01700
01800 IFC DEBUGGING THENC
01900 REAL NUDGEANGLE;
02000 DEFINE NUDGEINCR="π/16";
02100 DEFINE NUDGEMAGN="0.01";
02200
02300 INITIALIZE (NUDGEANGLE←0);
02400
02500 SIMPLE PROCEDURE NUDGE(INTEGER GS);
02600 BEGIN
03000 TRANSLATE(-GS,0,0,0.01);
03100 ROTATE(-GS,0,0,π/32);
03200 END;
03300 ENDC
00100 SIMPLE INTEGER PROCEDURE NGON(INTEGER SIDES);
00200 BEGIN
00300 ! CREATES THE LINKS FOR A BODY OF
00400 ONE FACE OF SIDES EDGES. RETURNS THE FACE;
00500 INTEGER F,B,I,V0,V;
00600 B←MKB(SHOP); F←MKF(B); V0←V←MKV(B);
00700 FOR I← 2 STEP 1 UNTIL SIDES DO
00800 BEGIN
00900 V←MKEV(F,V);
01000 END;
01100 MKFE(V0,F,V);
01200 RETURN(PFACE(F));
01300 END;
00100 INTEGER PROCEDURE C_CYL(ITEMVAR CYL,PNAM);
00200 BEGIN
00300 INTEGER E,F,C,V1,V2,SAMP,N,T,F0;
00400 REAL X,Y,Z;
00500 ITEMVAR FACEI,FCID,SFCID;
00600 LABEL DOPOLY;
00700
00800 IFC DEBUGGING THENC
00900 WRITE("ENTERING C_CYL. PNAM="&ITMNAM(PNAM));
01000 PRINT_REC(CYL);
01100 ENDC
01200
01300 FACEI←FPROT(CYL);
01400 FCID←PIDREC(PNAM,LFEID(CYL)); ! EVENTUALLY THE TOP FACE;
01500 CASE PROPS(FACEI) OF
01600 BEGIN
01700
01800 [PERCOD]BEGIN "PERIMETER"
01900 ! FOR NOW, THIS IS JUST LIKE POLYGON;
02000 GO TO DOPOLY;
02100 END;
02200
02300
02400 [POLCOD]BEGIN "POLYGON"
02500 DOPOLY: F←NGON(N←NPOINTS(FACEI));
02600 E←PED(F);
02700 FOR C←1 STEP 1 UNTIL N DO
02800 BEGIN
02900 V1←PVT(E);
03000 XWC(V1)←FACEXC(FACEI,C)*SIZE0(CYL);
03100 YWC(V1)←FACEYC(FACEI,C)*SIZE0(CYL);
03200 ZWC(V1)←0;
03300 PTNODE(E)←FCID;
03400 E←ECCW(E,F);
03500 END;
03600 END;
03700
03800 [CIRCOD]BEGIN "CIRCLE"
03900 F←NGON(CIRCLESIDES);
04000 Y←2*π/CIRCLESIDES;
04100 X←0; Z←∂(FACEI,REAL)*SIZE0(CYL);
04200 E←PED(F); V1←V2←VCCW(E,F);
04300 DO BEGIN
04400 XWC(V1)←Z*COS(X);
04500 YWC(V1)←Z*SIN(X);
04600 ZWC(V1)←0;
04700 X←X+Y;
04800 PTNODE(E)←FCID;
04900 E←ECCW(E,F); V1←VCCW(E,F);
05000 END UNTIL V1=V2;
05100 END;
05200
05300 [FUB] END;
05400
05500 ! NOW SWEEP THE FACE TO MAKE THE CYLINDER. FOR THE MOMENT ONLY
05600 WORRY ABOUT LINEAR SCALE CHANGES ALONG THE AXIS;
05700
05800 SWEEP(F,0);
05900 ! MUST FIND THE "BOTTOM" FACE;
06000 E←PED(F);F0←NFACE(F);C←E←PED(F0);
06100 FCID←PIDREC(PNAM,ZFEID(CYL));
06200 SFCID←PIDREC(PNAM,SFEID(CYL));
06300 DO BEGIN
06400 PTNODE(E)←FCID;
06500 PTNODE(ECW(E,OTHER(E,F0)))←SFCID;
06600 E←ECCW(E,F0);
06700 END UNTIL E=C;
06800 TRANSLATE(F,0,0,AXISL(CYL));
06900 X←SIZEL(CYL)/SIZE0(CYL);
07000 SHRINK(F,X,X,X);
07100 C←BGET(F);
07200
07300 IFC FALSE THENC
07400 ! UNTIL BGB GETS HIS SUBTRACTION CODE WORKING, PYRAMID
07500 EACH FACE;
07600
07700 PYRAMID(F);
07800 PYRAMID(F0);
07900 ENDC
08000
08100 RETURN(C);
08200 END;
00100 INTEGER PROCEDURE C_SPHERE(ITEMVAR SPH,PNAM);
00200 BEGIN
00300 INTEGER B,F,E,V,T,I,V0;
00400 ITEMVAR PID;
00500 ITEMVAR XS;
00600
00700 XS←XSPROT(SPH);
00800 CASE PROPS(XS) OF
00900 BEGIN
01000
01100 [PERCOD]BEGIN "PERIMETER"
01200 B←MKB(SHOP);F←MKF(B);V←V0←MKV(B);
01300 FOR I←1 STEP 1 UNTIL NPOINTS(XS) DO
01400 BEGIN
01500 XWC(V)←FACEXC(XS,I);
01600 YWC(V)←FACEYC(XS,I);
01700 ZWC(V)←0;
01800 IF I<NPOINTS(XS) THEN
01900 BEGIN
02000 V←MKEV(F,V);
02100 END
02200 ELSE IF XWC(V)=XWC(V0)∧YWC(V)=YWC(V0) THEN
02300 BEGIN
02400 E←MKFE(V,F,V0);
02500 END;
02600 END;
02700 END;
02800
02900 [POLCOD]BEGIN "POLYGON"
03000 ! SAME AS PERIMETER FOR NOW;
03100 B←MKB(SHOP);F←MKF(B);V←V0←MKV(B);
03200 PID←PIDREC(PNAM,NAMELESS);
03300 FOR I←1 STEP 1 UNTIL NPOINTS(XS) DO
03400 BEGIN
03500 XWC(V)←FACEXC(XS,I);
03600 YWC(V)←FACEYC(XS,I);
03700 ZWC(V)←0;
03800 IF I<NPOINTS(XS) THEN
03900 BEGIN
04000 V←MKEV(F,V);
04100 END
04200 ELSE IF XWC(V)=XWC(V0)∧YWC(V)=YWC(V0) THEN
04300 BEGIN
04400 E←MKFE(V,F,V0);
04500 END;
04600 END;
04700 END;
04800
04900 [HCCOD] BEGIN "CIRCLE"
05000 ! HALF CIRCLE;
05100 PID←PIDREC(PNAM,NAMELESS);
05200 B←MKB(SHOP);F←MKF(B);V←MKV(B);
05300 XWC(V)←SSIZE(SPH)*∂(XS,REAL);
05400 YWC(V)←ZWC(V)←0;
05500 FOR I←1 STEP 1 UNTIL CIRCLESIDES/2 DO
05600 BEGIN
05700 V←MKEV(F,V);
05800 ROTATE(V,0,0,2*π/CIRCLESIDES);
05900 END;
06000 KLNODE(T);
06100 END;
06200
06300
06400 [XSUB] END;
06500
06600
06700 FOR I←1 STEP 1 UNTIL CIRCLESIDES-1 DO
06800 BEGIN
06900 SWEEP(F,0);
07000 ROTATE(F,0,0,2*π/CIRCLESIDES);
07100 END;
07200 ROTCOM(F);
07300 ! NOW NAME THE BODY;
07400 PID←PIDREC(PNAM,NAMELESS);
07500 E←B;
07600 WHILE (E←PED(E))≠B DO
07700 PTNODE(E)←PID;
07800 RETURN(B);
07900 END;
00100 RECURSIVE INTEGER PROCEDURE C_BODY(ITEMVAR BODYI,PNAM);
00200 BEGIN
00300
00400 INTEGER B1,B2,B,X,E,E0;
00500 ITEMVAR PARTI,PID;
00600
00700 IFC DEBUGGING THENC
00800 WRITE("ENTERING C_BODY, PNAM="&ITMNAM(PNAM));
00900 PRINT_REC(BODYI);
01000 ENDC
01100
01200 IF PROPS(BODYI)=CYLCOD THEN
01300 RETURN(C_CYL(BODYI,PNAM))
01400 ELSE IF PROPS(BODYI)=SPHCOD THEN
01500 RETURN(C_SPHERE(BODYI,PNAM));
01600
01700 ! IF GET HERE EXPECT A PARTS LIST BODY;
01800
01900 B←0;
02000 ∀ PARTI | PARTI ε ∂(BODYI,LIST) DO
02100 BEGIN
02200 PID←PIDREC(PNAM,PARTID(PARTI));
02300 B2←C_BODY(BPROT(PARTI),PID);
02400 TRANSFORM(B2,∂(XFORM(PARTI),REAL ARRAY));
02500 IFC DEBUGGING THENC
02600 WRITE("BODY BUILT: "&CVOS(B2));
02700 WRITEON("TYPE A KEY ");INCHRW;
02800 SHOW1(WINDOW,1);
02900 WRITEON("TYPE A KEY ");INCHRW;
03000 ENDC
03100
03200 IF ¬B THEN
03300 BEGIN
03400 B1←B←B2;
03500 CONTINUE;
03600 END;
03700 IFC DEBUGGING THENC
03800 NUDGE(B1);
03900 WRITE ("NUDGED IT ");
04000 SHOW1(WINDOW,1);
04100 WRITE("TYPE A KEY AGAIN"); INCHRW;
04200 ENDC
04300 CASE ROLE(PARTI) OF
04400 BEGIN
04500
04600 [UCOD] B←BUN(B1,B2);
04700 [SCOD] B←BSUB(B1,B2);
04800 [ICOD] B←BIN(B1,B2);
04900
05000 [RUB] END;
05100
05200 ! NOW GO THROUGH AND DO THE NAME UPDATING;
05300
05400 IF PARTID(PARTI)≠GENID(PARTI) THEN
05500 PID←PIDREC(PNAM,GENID(PARTI));
05600
05700 E←B;
05800 WHILE (E←PED(E))≠B DO
05900 BEGIN
06000 IF ALT(E)=0 THEN
06100 PTNODE(E)←PID
06200 ELSE
06300 PTNODE(E)←PTNODE(ALT(E));
06400 END;
06500
06600 KLBFEV(B1);KLBFEV(B2);
06700 IFC DEBUGGING THENC
06800 WRITE ("BODY MERGED:"&CVOS(B));
06900 SHOW1(WINDOW,1);
07000 INCHRW;
07100 ENDC
07200 B1←B;
07300 END;
07400 RETURN(B);
07500 END;
00100 INTEGER PROCEDURE SHOW_BODY(ITEMVAR BODYI,PNAM);
00200 BEGIN
00300 INTEGER B;
00400 B←C_BODY(BODYI,PNAM);
00500 SHOW1(WINDOW,1);
00600 RETURN(B);
00700 END;
00100 COMMENT BODY DECLARATION PROCEDURES;
00200
00300 ITEMVAR PROCEDURE B_PART( ITEMVAR XF,BP;
00400 INTEGER RL;ITEMVAR PID,GID);
00500 BEGIN
00600 ITEMVAR PRT;
00700 PRT←RECORD(PRECIX);
00800 XFORM(PRT)←XF;
00900 BPROT(PRT)←BP;
01000 ROLE(PRT)←RL;
01100 PARTID(PRT)←PID;
01200 GENID(PRT)←GID;
01300 RETURN(PRT);
01400 END;
01500
01600 ITEMVAR PROCEDURE B_PLIST_BODY(LIST PL);
01700 BEGIN
01800 ITEMVAR PLB;
01900 PLB←NEW(PL);
02000 PROPS(PLB)←PLBCOD;
02100 RETURN(PLB);
02200 END;
02300
02400 ITEMVAR PROCEDURE B_CYL(REAL AX,S0,SL;ITEMVAR CHM,FP,ZFI,LFI,SFI);
02500 BEGIN
02600 ITEMVAR CYL;
02700 CYL←RECORD(CYLRECIX);
02800 AXISL(CYL)←AX;
02900 SIZE0(CYL)←S0;
03000 SIZEL(CYL)←SL;
03100 CHMETH(CYL)←CHM;
03200 FPROT(CYL)←FP;
03300 ZFEID(CYL)←ZFI;
03400 LFEID(CYL)←LFI;
03500 SFEID(CYL)←SFI;
03600 PROPS(CYL)←CYLCOD;
03700 RETURN(CYL);
03800 END;
03900
04000 ITEMVAR PROCEDURE B_SPHERE(REAL SS;ITEMVAR XSP);
04100 BEGIN
04200 ITEMVAR SPH;
04300 SPH←RECORD(SPHRECIX);
04400 SSIZE(SPH)←SS;
04500 XSPROT(SPH)←XSP;
04600 PROPS(SPH)←SPHCOD;
04700 RETURN(SPH);
04800 END;
04900
05000 ITEMVAR PROCEDURE B_CIRC_FACE(REAL R);
05100 BEGIN
05200 REAL ITEMVAR CF;
05300 CF←NEW(R);
05400 PROPS(CF)←CIRCOD;
05500 RETURN(CF);
05600 END;
05700
05800 ITEMVAR PROCEDURE B_CIRC_XS(REAL R);
05900 BEGIN
06000 REAL ITEMVAR CF;
06100 CF←NEW(R);
06200 PROPS(CF)←HCCOD;
06300 RETURN(CF);
06400 END;
06500
06600 REAL ARRAY ITEMVAR PROCEDURE B_XF(REAL X0,Y0,Z0,AX,AY,AZ,W);
06700 BEGIN
06800 ! DILATE BY W, ROTATE BY AX,AY,AZ. TRANSLATE TO A0,Y0,Z0;
06900 REAL ARRAY X[1:7];
07000 ITEMVAR XF;
07100 X[1]←X0;X[2]←Y0;X[3]←Z0;X[4]←AX;X[5]←AY;X[6]←AZ;X[7]←W;
07200 SET_TYPE(XF←NEW,17); ! REAL ARRAY;
07300 ∂(XF,INTEGER)←LOCATION(X[1]);
07400 MEMLOC(X,INTEGER)←0; ! FOOL THE BLOCK EXITER;
07500 RETURN(XF);
07600 END;
07700
07800 ITEMVAR PROCEDURE B_RECT_FACE(REAL X,Y);
07900 BEGIN
08000 REAL ARRAY PTS[0:4,0:1];
08100 MEMORY[LOCATION(PTS[0,0]),INTEGER]←4;
08200 PTS[1,0]←PTS[2,0]←X;
08300 PTS[3,0]←PTS[4,0]←-X;
08400 PTS[1,1]←PTS[4,1]←Y;
08500 PTS[2,1]←PTS[3,1]←-Y;
08600 RETURN(NEW(PTS));
08700 END;
08800
00100
00200 INTEGER T,GSTRUCT,V,C;
00300
00400 REQUIRE "FROB.SAI" SOURCE_FILE;
00500
00600 SHOP←MKWORLD;
00700 WINDOW←MKWINDOW;
00800 CAMERA←MKCAMERA;
00900 BATT(SHOP,WINDOW);
01000 BATT(CAMERA,WINDOW);
01100
01200 BUILD_FROB;
01300
01400 IFC DEBUGGING THENC
01500 PRINT_REC(FROB);
01600 PRINT_REC(BORE);
01700 PRINT_REC(INNER_CUT);
01800 PRINT_REC(PEDESTAL);
01900 PRINT_REC(SHAFT);
02000 ENDC
02100
02200 V←1;
02300 GSTRUCT←C_BODY(FROB,FROB);
02400 WHILE TRUE DO
02500 BEGIN
02600 CASE V OF
02700 BEGIN
02800 [0] SHOW1(WINDOW,1);
02900 [1] SHOW1(WINDOW,1);
03000 [2] END;
03100 C←INCHRW;
03200 IF C="X" THEN DONE;
03300 IF C="↑" THEN
03400 BEGIN
03500 ROTATE(-GSTRUCT,0,0,π/20);
03600 END
03700 ELSE IF C="↓" THEN
03800 BEGIN
03900 ROTATE(-GSTRUCT,0,0,-π/20);
04000 END
04100 ELSE IF C="→" THEN
04200 BEGIN
04300 ROTATE(-GSTRUCT,0,-π/20,0);
04400 END
04500 ELSE IF C="←" THEN
04600 BEGIN
04700 ROTATE(-GSTRUCT,0,π/20,0);
04800 END;
04900 END;
05000
05100 END "SPINE"